#light
namespace Strangelights.FSharp
/// A module for dealing with XML in an idiomatic functional style
module Xml =
    open System.Xml
    open System.Text
    open System.IO

    /// represents an xml attribute
    type XmlAttribute =
        { AttribName: string;
          AttribValue: string; }
    
    /// represents a processing instruction
    type ProcessingInstruction =
        { PiName: string;
          PiText: string }
    
    /// represents an xml element
    type XmlElement =
        { ElementName: string;
          Attributes: XmlAttribute list;
          InnerXml: XmlTree }
          
    /// represents an XML tree
    and XmlTree =
      | Element of XmlElement
      | ElementList of list<XmlTree>
      | Text of string
      | Comment of string 
      | ProcessingInstruction of ProcessingInstruction
      | CData of string
      | Empty
      
    /// creates a text node    
    let text text =
      Text text

    /// createas a comment node
    let comment text =
      Comment text
    
    /// creates a processing instruction node
    let procInstruc name text =
      ProcessingInstruction { PiName = name; PiText = text }
      
    /// creates an empty element
    let empty = Empty
    
    /// creates a CDATA node
    let cdata text = 
        CData text

    /// creates an element list
    let elementList els =
      ElementList els
    
    /// creates an attribute node
    let attrib name value = 
        { AttribName = name;
          AttribValue = value }

    /// creates an element node
    let element name attribs innerXml =
        let attribs = List.map (fun (name, value) -> attrib name value) attribs
        Element { ElementName = name; 
                  Attributes = attribs;
                  InnerXml = innerXml }
                
    /// creates an element node that contains a text node
    let textElement name attribs innerText =
      element name attribs (text innerText)
    
    /// creates an empty element  
    let emptyElement name attribs =
      element name attribs empty
    
    /// creates an element node with a sub elementList
    let elementSubElems name attribs innerElems =
        element name attribs (elementList innerElems)
        
    /// concatenates two elements, if either element is alread an element
    /// list then the two lists are merged, otherwise a new list is created
    let concat el1 el2 =
      match el1, el2 with
      | ElementList list1, ElementList list2 -> ElementList (list1 @ list2)
      | _, ElementList list2 -> ElementList (el1 :: list2)
      | ElementList list1, _ -> ElementList (list1 @ [el2])
      | _ -> ElementList [el1 ; el2]
      
    /// writes the given xml tree to the given XmlWriter
    let writeToXmlWriter (writer:#XmlWriter) xml =
      // inner loop to save each xml node
      let rec innerSave xml = 
          match xml with
          | Element elem -> 
            writer.WriteStartElement(elem.ElementName)
            elem.Attributes |> List.iter(fun { AttribName = name; AttribValue = value } -> writer.WriteAttributeString(name, value)) 
            innerSave elem.InnerXml
            writer.WriteEndElement()
          | ElementList elements -> elements |> List.iter innerSave
          | Text text -> 
            writer.WriteString(text)
          | Comment text -> 
            writer.WriteComment(text)
          | ProcessingInstruction { PiName = name; PiText = text } -> 
            writer.WriteProcessingInstruction(name, text)
          | CData data -> 
            writer.WriteCData(data)
          | Empty -> ()
      // start loop
      innerSave xml

    /// writes the given xml tree to the given path, over writing any existing file
    let writeToFile (path:string) xml =
        use writer = new XmlTextWriter(path, Encoding.Unicode, Formatting = System.Xml.Formatting.Indented)
        writeToXmlWriter writer xml
        
    /// writes the given xml tree to the a string
    let writeToString xml =
        let stringWriter = new StringWriter()
        use writer = new XmlTextWriter(stringWriter, Formatting = System.Xml.Formatting.Indented)
        writeToXmlWriter writer xml
        stringWriter.ToString()

(* Niether this or the other implmentation is that great in terms of white space ...        
    let writeTreeToTextWriter2 (writer:#TextWriter) xml =
        // inner loop to save each xml node
        let rec innerSave indents xml = 
            let padding = String.make indents ' '
            let indents = indents + 2
            let writeAttribs =
                List.iter(fun { AttribName = name; AttribValue = value } -> writer.Write(" \"{0}\", \"{1}\";", name, value))
            match xml with
            | Element { ElementName = name; Attributes = attribs; InnerXml = Empty } -> 
                writer.Write(padding + "Xml.emptyElement \"{0}\" [", name) 
                writeAttribs attribs 
                writer.WriteLine("]") 
            | Element { ElementName = name; Attributes = attribs; InnerXml = Text text } -> 
                writer.Write(padding + "Xml.textElement \"{0}\" [", name) 
                writeAttribs attribs 
                writer.WriteLine("] \"{0}\"", text) 
            | Element { ElementName = name; Attributes = attribs; InnerXml = innerXml } -> 
                writer.Write(padding + "Xml.element \"{0}\" [", name) 
                writeAttribs attribs 
                writer.Write("] (") 
                innerSave indents innerXml 
                writer.WriteLine(padding + ")") 
            | ElementList elements -> 
                writer.Write(padding + "Xml.elementList [")
                let saveItem xml =
                     innerSave indents xml 
                     writer.Write("; ")
                elements |> List.iter saveItem
                writer.Write(padding + "] ") 
            | Text text -> writer.WriteLine(padding + "Xml.text \"{0}\" ", text)
            | Comment text -> writer.WriteLine(padding + "Xml.comment \"{0}\" ", text)
            | ProcessingInstruction { PiName = name; PiText = text } -> 
                writer.WriteLine(padding + "Xml.procInstruc \"{0}\" \"{1}\" ", name, text)
            | CData data -> writer.WriteLine(padding + "Xml.cdata \"{0}\" ", data)
            | Empty -> writer.WriteLine(padding + "Xml.empty")
        // start loop
        innerSave 0 xml 
*)

    let writeTreeToTextWriter (writer: 'a :> TextWriter) xml =
        // inner loop to save each xml node
        let rec innerSave indents writer xml = 
            let padding = String.make indents ' '
            let indents = indents + 2
            let writeAttribs writer =
                List.iter(fun { AttribName = name; AttribValue = value } -> 
                    Printf.fprintf writer " \"%s\", \"%s\";" name value)
            match xml with
            | Element { ElementName = name; Attributes = attribs; InnerXml = Empty } -> 
                Printf.fprintfn writer "%sXml.emptyElement \"%s\" [%a]" name padding writeAttribs attribs 
            | Element { ElementName = name; Attributes = attribs; InnerXml = Text text } -> 
                Printf.fprintfn writer "%sXml.textElement \"%s\" [%a] \"%s\"" padding name writeAttribs attribs text
            | Element { ElementName = name; Attributes = attribs; InnerXml = innerXml } -> 
                Printf.fprintfn writer "%sXml.element \"%s\" [%a] (%a)" padding name writeAttribs attribs (innerSave indents) innerXml
            | ElementList elements -> 
                let saveItems writer xml =
                     elements |> List.iter (fun xml -> Printf.fprintf writer " %a; " (innerSave indents) xml)
                Printf.fprintfn writer "%sXml.elementList [%a]" padding saveItems elements
            | Text text -> Printf.fprintfn writer "%sXml.text \"%s\" " padding text
            | Comment text -> Printf.fprintfn writer "%sXml.comment \"%s\" " padding text
            | ProcessingInstruction { PiName = name; PiText = text } -> 
                Printf.fprintfn writer "%sXml.procInstruc \"%s\" \"%s\" " padding name text
            | CData data -> Printf.fprintfn writer "%sXml.cdata \"%s\" " padding  data
            | Empty -> Printf.fprintfn writer "%sXml.empty" padding
        // start loop
        innerSave 0 (writer :> TextWriter) xml 

    let writeTreeToFile path xml =
        use outFile = File.CreateText(path)
        writeTreeToTextWriter outFile xml 

    let writeTreeToString xml =
        let stringWriter = new StringWriter()
        writeTreeToTextWriter stringWriter xml 
        stringWriter.ToString()

    /// read xml tree from an Xml text reader      
    let readFromXmlReader (reader:#XmlReader) =
        // function to read attributes, since they are "special"
        let rec readAttributes attribs =
            if reader.MoveToNextAttribute() then
               readAttributes ((reader.Name, reader.Value) :: attribs)
            else 
               List.rev attribs
    
        // inner loop to read the xml 
        let rec readNode prevNodeDepth elements sibblings =
            if reader.Read() then
                // create short hand for inner loop - since we need the depth all the time
                let readNode = readNode reader.Depth 
                match reader.NodeType with
                | XmlNodeType.XmlDeclaration -> elementList [ procInstruc "xml" "version=\"1.0\""; readNode elements sibblings]
                | XmlNodeType.Document // think document should just be treaded as an element
                | XmlNodeType.Element -> 
                    // read all state from the reader before reading attributes since this alters
                    // the readers state
                    let name = reader.Name
                    let depth = reader.Depth
                    let empty = reader.IsEmptyElement
                    let nodeAttribs = readAttributes []
                    if empty then
                      // nodes is empty create new node and stick it on sibbling list                                          
                      readNode elements ((emptyElement name nodeAttribs, depth) :: sibblings)
                    else
                      // nodes contains other nodes, stick it on the elements list                                          
                      readNode ((name, nodeAttribs, depth) :: elements) sibblings
                | XmlNodeType.EndElement -> 
                    // pop elements list find node we're create
                    let name, currentAttribs, depth = List.hd elements
                    System.Diagnostics.Debug.Assert(reader.Name = name, "Name of node being created must match name of end node being read")
                    
                    // find all nodes that should be placed under the node being created
                    // and create a new node
                    let sibblings,others = List.partition (fun (_,x) -> x = prevNodeDepth ) sibblings
                    let sibblings = List.map (fun (x,_) -> x) sibblings |> List.rev
                    let newElement = 
                        match sibblings with
                        | [x] ->  element name currentAttribs x
                        | _ -> element name currentAttribs (elementList sibblings)
                        
                    // continue reading nodes
                    readNode  (List.tl elements) ((newElement, reader.Depth) :: others)
                | XmlNodeType.CDATA -> readNode  elements (((cdata reader.Value), reader.Depth) :: sibblings)
                | XmlNodeType.ProcessingInstruction -> readNode elements  (((procInstruc reader.Name reader.Value), reader.Depth)  :: sibblings)
                | XmlNodeType.Comment -> readNode elements  (((comment reader.Value), reader.Depth) :: sibblings)
                | XmlNodeType.Text -> readNode elements  (((text reader.Value), reader.Depth) :: sibblings)
                | XmlNodeType.SignificantWhitespace -> readNode elements ((text reader.Value, reader.Depth) :: sibblings)
                | XmlNodeType.Whitespace -> readNode elements  sibblings // ignore whitespace for now
                | XmlNodeType.Attribute -> failwith "Attributes should only appear under an element"
                | XmlNodeType.DocumentFragment
                | XmlNodeType.DocumentType
                | XmlNodeType.Entity
                | XmlNodeType.EndEntity
                | XmlNodeType.EntityReference
                | XmlNodeType.Notation -> failwith "unsuported xml node type"
                | XmlNodeType.None -> failwith "the none node should never appear"
                | _ -> failwith "Unknown xml none type"
            else
                // we've run out of nodes to create so return the node we've found
                //printfn "sibblings.Length: %A" sibblings.Length
                //printfn "sibblings.Length: %A" sibblings
                //System.Diagnostics.Debug.Assert(elements.IsNil, "At end of parsing elements list should be empty")
                //System.Diagnostics.Debug.Assert(sibblings.Length = 1, "At end of parsing sibblings list should contain one element")
                let sibblings = List.map (fun (x,_) -> x) sibblings |> List.rev
                let res = 
                    match sibblings with
                    | [x] -> x
                    | _ -> elementList sibblings
                res
        
        // start the inner loop
        readNode (-1) [] []
        
    /// Read an xml tree from the given file    
    let readFromFile (path:string) =
        use reader = new XmlTextReader(File.OpenText(path))
        readFromXmlReader reader

    /// Read an xml tree from the given string
    let readFromString (xml:string) =
        use reader = new XmlTextReader(new StringReader(xml))
        readFromXmlReader reader
